home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-17 / mouse.zip / VIDEO.PAS < prev   
Pascal/Delphi Source File  |  1991-07-12  |  6KB  |  350 lines
  1. Unit VIDEO;
  2.  
  3. Interface
  4.  
  5. Uses Dos,Crt;
  6.  
  7. Type
  8.     ScreenChars = Record
  9.       ch : Char;
  10.       at : Byte;
  11.     End;
  12.  
  13.     screens = Record
  14.       Position : Array[1..25, 1..80] of ScreenChars;
  15.       x,y :Byte;
  16.     end;
  17.  
  18.     Screentype = (Mono, Color);
  19.  
  20. var
  21.    Stype : Screentype;
  22.    VidSeg : Word;
  23.    xx : Integer;
  24.  
  25. Procedure ShowScreen (Var Source, Video; Length: Word);
  26.  
  27. Procedure Getscreen (Var Video, Source; Length: Word);
  28.  
  29. Procedure XYstring(x, y: Byte;
  30.                    s: String;
  31.                    fg,
  32.                    bg: Byte);
  33.  
  34. Procedure ReadScr(Var S);
  35.  
  36. Procedure WriteScr(Var S);
  37.  
  38. Procedure HorStr(X, Y, Len : Byte;
  39.                  fg, bg: Byte;
  40.                  Ch : Char);
  41.  
  42. Procedure VerStr(X, Y, Len : Byte;
  43.                  fg, bg: Byte;
  44.                  Ch : Char);
  45.  
  46. Procedure Box(x1, y1, x2, y2 : Byte;
  47.               fg, bg : Byte);
  48.  
  49. Procedure Center(y : Byte;
  50.                  st : String;
  51.                  fg,
  52.                  bg : Byte);
  53.  
  54. Procedure BoxString(y : Byte;
  55.                     st :  String;
  56.                     fg,
  57.                     bg : Byte);
  58.  
  59. Procedure FillScreen(Var sc : Screens;
  60.                      s : String;
  61.                      x, y : Byte;
  62.                      fg, bg : Byte);
  63.  
  64. Procedure CursorOff;
  65.  
  66. Procedure CursorSmall;
  67.  
  68. Procedure CursorBig;
  69.  
  70.  
  71. Implementation
  72.  
  73. Var
  74.    Regs : Registers;
  75.    Vid : Pointer;
  76.  
  77.  
  78. Procedure ShowScreen(Var Source, Video;
  79.                             Length: Word);
  80. Begin
  81. If Stype = Color Then
  82.    Inline($90/$90/$90/
  83.           $1E/$55/$BA/$DA/$03/$C5/$B6/ Source /$C4/$BE/ Video /
  84.           $8B/$8E/ Length /$FC/$AD/$89/$C5/$B4/$09/$EC/$D0/$D8/
  85.           $72/$FB/$FA/$EC/$20/$E0/$74/$FB/$89/$E8/$AB/$FB/$E2/
  86.           $EA/$5D/$1F)
  87.  
  88. Else
  89.     Begin
  90.     Length := Length * 2;
  91.     Move(Source, Video, Length);
  92.     end;
  93. End;
  94.  
  95.  
  96. Procedure GetScreen(Var Video , Source;
  97.                         Length: Word);
  98.  
  99. Begin
  100. If Stype = Color Then
  101.    Inline($1E/$55/$BA/$DA/$03/$C5/$B6/ Video /$C4/$BE/ Source /
  102.           $8B/$8E/Length /$FC/$EC/$D0/$D8/$72/$FB/$FA/$EC/$D0/
  103.           $D8/$73/$FB/$AD/$FB/$AB/$E2/$F0/$5D/$1F)
  104.  
  105. Else
  106.     begin
  107.     length := length * 2;
  108.     Move(Video, Source, Length);
  109.     end;
  110. End;
  111.  
  112.  
  113. Procedure XYstring(x, y: Byte;
  114.                    s: String;
  115.                    fg, bg: Byte);
  116.  
  117. Var
  118.    SA : Array[1..255] of Record
  119.       ch : Char;
  120.       at : byte;
  121.       End;
  122.  
  123.    b, i : Byte;
  124.    offset : Word;
  125.  
  126. Begin
  127. If (Length(s) = 0) Or
  128.    (x > 80) Or
  129.    (x < 1) Or
  130.    (y > 25) Or
  131.    (y < 1) Then Exit;
  132.  
  133. b := (Ord(bg) Shl 4) Or Ord(fg);
  134.  
  135. FillChar(SA, SizeOf(SA), b);
  136. For i := 1 to Length(s) Do
  137.     Sa[i].ch := s[i];
  138.  
  139. offset := (((y-1) *80) + (x-1))*2;
  140.  
  141. Vid := Ptr (Vidseg,offset);
  142.  
  143. Showscreen(SA, Vid^, Length(s));
  144. End;
  145.  
  146.  
  147. Procedure ReadScr(Var S);
  148.  
  149. Begin
  150. Vid := Ptr(Vidseg, 0);
  151. Showscreen(S, Vid^, 2000);
  152. End;
  153.  
  154.  
  155. Procedure WriteScr(Var S);
  156.  
  157. Begin
  158. Vid := Ptr(Vidseg,0);
  159. Showscreen(S, Vid^, 2000);
  160. End;
  161.  
  162.  
  163. Procedure HorStr(x, y, Len : Byte;
  164.                  fg, bg: Byte;
  165.                  ch : Char);
  166.  
  167. Var
  168.    i : Byte;
  169. Begin
  170. For i := 1 To Len Do
  171.     Begin
  172.     XYString(x,y,ch,fg,bg);
  173.     x := x + 1;
  174.     End;
  175. End;
  176.  
  177.  
  178.  
  179. Procedure VerStr(x, y, Len : Byte;
  180.                  fg,bg: Byte;
  181.                  ch : Char);
  182.  
  183. Var
  184.    i : Byte;
  185. Begin
  186. For i := 1 To Len Do
  187.     Begin
  188.     XYString(x,y,ch,fg,bg);
  189.     y := y + 1;
  190.     End;
  191. End;
  192.  
  193.  
  194.  
  195. Procedure Box(x1, y1, x2, y2 : Byte;
  196.               fg, bg : Byte);
  197.  
  198. Begin
  199. If (x1 < 1) Or
  200.    (x2 > 80) Or
  201.    (y1 < 1) Or
  202.    (y2 > 25) Or
  203.    ((x2-x1) < 2) Or
  204.    ((y2-y1) < 2) Then Exit;
  205.  
  206. HorStr(x1, y1, 1, fg, bg, #201);
  207. HorStr(x2, y1, 1, fg, bg, #187);
  208. HorStr(x1, y2, 1, fg, bg, #200);
  209. HorStr(x2, y2, 1, fg, bg, #188);
  210. VerStr(x1, y1+1, y2-y1-1, fg, bg, #186);
  211. For xx:=x1+1 to x2-1 do
  212. Begin
  213.      VerStr(xx, y1+1, y2-y1-1, fg, bg, ' ');
  214. End;
  215. VerStr(x2, y1+1, y2-y1-1, fg, bg, #186);
  216. HorStr(x1+1, y1, x2-x1-1, fg, bg, #205);
  217. HorStr(x1+1, y2, x2-x1-1, fg, bg, #205);
  218. End;
  219.  
  220.  
  221.  
  222. Procedure Center(y : Byte;
  223.                  st : String;
  224.                  fg,
  225.                  bg : Byte);
  226.  
  227. Var
  228.    x : Byte;
  229.  
  230. Begin
  231. x := (40-(Length(st) Div 2));
  232. XYString(x, y, st, fg, bg);
  233. End;
  234.  
  235.  
  236.  
  237. Procedure BoxString(y : Byte;
  238.                     st : String;
  239.                     fg, bg : Byte);
  240.  
  241. Var
  242.    x1, y1, x2, y2 : Byte;
  243.  
  244. Begin
  245. Center(y, st, fg, bg);
  246. x1 := 40-(Length(st) Div 2) -2;
  247. x2 := x1+Length(st)+3;
  248. y1 := y-1;
  249. y2 := y+1;
  250. Box(x1, y1, x2, y2, fg, bg);
  251. End;
  252.  
  253.  
  254. Procedure FillScreen(Var sc : screens;
  255.                       s : String;
  256.                       x, y : Byte;
  257.                       fg,bg : Byte);
  258.  
  259. Var
  260.    i, atx : Byte;
  261. Begin
  262. atx := fg Or (bg Shl 4);
  263.  
  264. For i := 1 To Length(s) Do
  265.     Begin
  266.     sc.position[y,x].ch := s[i];
  267.     sc.position[y,x].at := atx;
  268.     x := x+1;
  269.     If x > 80 Then
  270.        Begin
  271.        x := 1;
  272.        y := y+1;
  273.        If y>25 Then
  274.           Exit;
  275.        End;
  276.     End;
  277. End;
  278.  
  279.  
  280.  
  281. Procedure CursorOff;
  282. Begin
  283. FillChar(Regs, sizeof(Regs),0);
  284.  
  285. With Regs Do
  286.      Begin
  287.      AH := $01;
  288.      CH := $20;
  289.      CL := $20;
  290.      End;
  291.  
  292. Intr($10, Regs);
  293. End;
  294.  
  295.  
  296.  
  297. Procedure CursorSmall;
  298. Begin
  299. FillChar(Regs,sizeof(Regs),0);
  300. regs. AH := $01;
  301.  
  302.       Case stype of
  303.       Mono :
  304.            Begin
  305.            With Regs Do
  306.                 begin
  307.                 CH := 12;
  308.                 CL := 13;
  309.                 End;
  310.            End;
  311.       End;
  312.  
  313. Intr($10, Regs);
  314. End;
  315.  
  316.  
  317.  
  318. Procedure CursorBig;
  319. Begin
  320. FillChar(Regs, sizeof(Regs),0);
  321. regs.AH := 1;
  322. regs.CH := 0;
  323.  
  324.     Case stype of
  325.     Mono : regs.CL :=13;
  326.     Color : regs.CL :=7;
  327.     End;
  328.  
  329. Intr($10, Regs);
  330. End;
  331.  
  332.  
  333. Begin
  334. FillChar(regs,sizeof(regs),0);
  335. Regs.AH := $0F;
  336.  
  337. Intr($10,Regs);
  338. If Regs.AL = 7 Then
  339.    Begin
  340.    Stype := Mono;
  341.    Vidseg := $b000;
  342.    End
  343. Else
  344.     Begin
  345.     Stype := Color;
  346.     Vidseg := $B800;
  347.     End;
  348. End.
  349.  
  350.